home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / eval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-24  |  17.6 KB  |  669 lines
  1. /*
  2.  *
  3.  * e v a l . c                -- The evaluator
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 23-Oct-1993 21:37
  22.  * Last file update: 24-Jul-1996 17:03
  23.  */
  24.  
  25. #include "stk.h"
  26. #include "extend.h"
  27. #ifdef USE_STKLOS
  28. #  include "stklos.h"
  29. #endif
  30.  
  31. #define RETURN(x)        {tmp = (x); goto Out; }
  32.  
  33. /*
  34.  * STk_eval_flag indicates if eval has something to test (a ^C has
  35.  * occured, a eval-hook to apply, ...). Using this flag allow to
  36.  * minimize the number of tests done in eval the eval function (which
  37.  * must be as fast as possible since we spent most of our time in it).
  38.  * When this flag is up, the set of possible "diverting" things are 
  39.  * tested.
  40.  * This flag could also probably used for implementing a thread mechanism.
  41.  *
  42.  */
  43.  
  44. int STk_eval_flag = 0;
  45.  
  46. /*
  47.  * Eval stack
  48.  * 
  49.  * The eval stack is a stack of the arguments passed to eval. This stack permits
  50.  * to facilitate debugging  of Scheme programs. Its contents is displayed 
  51.  * when an error occurs.
  52.  * Note that "STk_eval_stack" does'nt need to be protected since it contains 
  53.  * pointers which are themselves copies of the eval C routine. Eval parameters
  54.  * will be marked as are all the objects which are in the C stack
  55.  * */
  56.  
  57. static struct Stack_info {
  58.   SCM expr, env;
  59.   struct Stack_info *previous;
  60. } *stack = NULL;
  61.  
  62.  
  63. void STk_show_eval_stack(int depth)
  64. {
  65.   int j;
  66.   struct Stack_info *p;
  67.  
  68.   fprintf(STk_stderr, "\nCurrent eval stack:\n__________________\n");
  69.   for (p=stack, j=0; p && j<=depth ; p=p->previous, j++) {
  70.     fprintf(STk_stderr, "%3d    ", j);
  71.     STk_print(STk_uncode(p->expr), STk_curr_eport, WRT_MODE);
  72.     Putc('\n', STk_stderr);
  73.     if (j == depth && p->previous) fprintf(STk_stderr, "...\n");
  74.   }
  75. }
  76.  
  77. void STk_reset_eval_stack(void)
  78. {
  79.   stack = NULL;
  80. }
  81.  
  82. PRIMITIVE STk_get_eval_stack(void)
  83. {
  84.   struct Stack_info *p;
  85.   SCM              z = NIL;
  86.   
  87.   for (p = stack; p ; p = p->previous) z = Cons(p->expr, z);
  88.   
  89.   return STk_reverse(z);
  90. }
  91.  
  92. PRIMITIVE STk_get_env_stack(void)
  93. {
  94.   struct Stack_info *p;
  95.   SCM              z = NIL;
  96.   
  97.   for (p = stack; p ; p = p->previous)  {
  98.     /* Avoid to create an environment for each item */
  99.     SCM tmp = (z!=NIL && STk_equal(CAR(z)->storage_as.env.data,p->env)==Truth) ?
  100.               CAR(z): 
  101.               STk_makeenv(p->env, 0);
  102.     z = Cons(tmp, z);
  103.   }
  104.   return  STk_reverse(z);
  105. }
  106.  
  107.  
  108. SCM STk_top_env_stack(void)
  109. {
  110.   return stack ? STk_makeenv(stack->env, 0): STk_globenv;
  111. }
  112.  
  113. static SCM eval_args(SCM l, SCM env)
  114. {
  115.   SCM result,v1,v2;
  116.  
  117.   if (NULLP(l)) return NIL;
  118.  
  119.   v1 = result = Cons(EVALCAR(l), NIL);
  120.   
  121.   for(v2=CDR(l); CONSP(v2); v2=CDR(v2)) {
  122.     v1 = CDR(v1) = Cons(EVALCAR(v2),NIL);
  123.   }
  124.   return result;
  125. }
  126.  
  127. static SCM eval_cond(SCM *pform, SCM env)
  128. {
  129.   SCM l, clause, tmp, res = Truth;
  130.  
  131.   for (l=*pform; NNULLP(l); l = CDR(l)) {
  132.     clause = CAR(l);
  133.     /* We are sure that clause is a cons here (see syntax_cond) */
  134.     if (EQ(CAR(clause), Sym_else) || (res=EVALCAR(clause)) != Ntruth) {
  135.       tmp = CDR(clause);
  136.       if (NULLP(tmp))  SYNTAX_RETURN(res, Ntruth);
  137.       if (NCONSP(tmp)) goto Error;
  138.  
  139.       if (EQ(CAR(tmp), Sym_imply)) {
  140.     /* Clause is ((condition) => function) */
  141.     if (STk_llength(tmp) != 2) Err("cond: malformed `=>'", tmp);
  142.     SYNTAX_RETURN(Apply(EVALCAR(CDR(tmp)), LIST1(res)), Ntruth);
  143.       }
  144.       else {
  145.     for( ; NNULLP(CDR(tmp)); tmp=CDR(tmp))
  146.       EVALCAR(tmp);
  147.     SYNTAX_RETURN(CAR(tmp), Truth);
  148.       }
  149.     }
  150.   }
  151.   SYNTAX_RETURN(UNDEFINED, Ntruth);
  152. Error:
  153.   Err("cond: bad clause body", clause);
  154.   return UNDEFINED; /* never reached */
  155. }
  156.  
  157. /*
  158.  * *eval-hook* management.
  159.  *
  160.  * STk eval-hook mechanism is similar to the CL one. The *eval-hook*
  161.  * Scheme variable is managed as a C-variable which has a getter and a
  162.  * setter function associated to it. The functions below allow to
  163.  * manage a stack of hooks in the C stack. Each hook info is stored in
  164.  * a Eval_hook_info structure
  165.  * 
  166.  */
  167.  
  168. struct Eval_hook_info {
  169.   SCM hook;
  170.   int bypass_check;
  171.   struct Eval_hook_info *previous;
  172. };
  173.  
  174. static struct Eval_hook_info  eval_hook_bottom;
  175. static struct Eval_hook_info *eval_hook_stack = &eval_hook_bottom;
  176.  
  177.  
  178. static SCM get_eval_hook(char *s)
  179. {
  180.   return eval_hook_stack->hook;
  181. }
  182.  
  183. static void set_eval_hook(char *unused, SCM value)
  184. {
  185.   if (value == Ntruth) {
  186.     eval_hook_stack       = &eval_hook_bottom;
  187.     eval_hook_stack->hook  = Ntruth;
  188.   }
  189.   else {
  190.     if (STk_procedurep(value) == Ntruth) 
  191.       STk_err("Hook value must be #f or a procedure. It is", value);
  192.  
  193.     eval_hook_stack->hook        = value;
  194.     eval_hook_stack->bypass_check = FALSE;
  195.     SET_EVAL_FLAG(1);
  196.   }
  197. }
  198.  
  199. static SCM handle_eval_hook(SCM x, SCM env)
  200. {
  201.   struct Eval_hook_info info;
  202.   SCM res;
  203.   
  204.   /* Reset eval-hook to avoid recursive application */
  205.   info.previous     = eval_hook_stack;
  206.   info.hook         = Ntruth;
  207.   info.bypass_check = FALSE;
  208.   eval_hook_stack   = &info;
  209.  
  210.   /* Call user code */
  211.   res = STk_apply(info.previous->hook, LIST2(x, STk_makeenv(env, 0)));
  212.   
  213.   /* If we are here, everything was correct */
  214.   eval_hook_stack = info.previous;
  215.   SET_EVAL_FLAG(1);
  216.   return res;
  217. }
  218.  
  219.  
  220. void STk_reset_eval_hook(void)
  221. {
  222.   eval_hook_stack        = &eval_hook_bottom;
  223.   eval_hook_stack->hook         = Ntruth;
  224.   eval_hook_stack->bypass_check = FALSE;
  225.   eval_hook_stack->previous     = &eval_hook_bottom; /* itself */
  226. }
  227.  
  228.  
  229. void STk_init_eval_hook(void)
  230. {
  231.   STk_define_C_variable(EVAL_HOOK, get_eval_hook, set_eval_hook);
  232.   STk_gc_protect(&eval_hook_bottom.hook);
  233.   STk_reset_eval_hook();
  234. }
  235.  
  236.  
  237. PRIMITIVE STk_eval_hook(SCM x, SCM env, SCM hook)
  238. {
  239.   SCM res;
  240.   struct Eval_hook_info info;
  241.  
  242.   info.hook         = hook;
  243.   info.bypass_check = TRUE;
  244.   info.previous     = eval_hook_stack;
  245.   eval_hook_stack   = &info;
  246.   SET_EVAL_FLAG(1);
  247.  
  248.   res = STk_eval(x, env->storage_as.env.data);
  249.   eval_hook_stack = info.previous;
  250.   SET_EVAL_FLAG(1);
  251.  
  252.   return res;
  253. }
  254.  
  255. /*
  256.  *
  257.  * E V A L
  258.  * 
  259.  */
  260.  
  261. SCM STk_eval(SCM x, SCM env)
  262. {
  263.   register SCM tmp, fct;
  264.   register int len;
  265.   struct Stack_info infos;
  266.  
  267.   infos.previous = stack; stack = &infos;
  268. Top:
  269.   infos.expr = x; infos.env = env; 
  270.   if (STk_eval_flag) {
  271.     /* We have something to test before evaluating the form:
  272.      *        - a ^C ?
  273.      *        - *eval-hook*?
  274.      */
  275.     
  276.     if (STk_control_C && !STk_sigint_counter) STk_handle_signal(SIGINT);
  277.     
  278.     if (eval_hook_stack->hook != Ntruth) {
  279.       if (eval_hook_stack->bypass_check) {
  280.     eval_hook_stack->bypass_check = FALSE;
  281.     if (CONSP(x)) {
  282.       fct = EVAL(CAR(x)); /* Don't use EVALCAR here of course */
  283.       goto Apply_args;
  284.     }
  285.       }
  286.       else
  287.     RETURN(handle_eval_hook(x, env));
  288.     }
  289.     SET_EVAL_FLAG(STk_control_C || 
  290.           (eval_hook_stack->hook != Ntruth));
  291.   }
  292.  
  293.   switch TYPE(x) {
  294.     case tc_symbol:
  295.          RETURN(*STk_varlookup(x, env, 1));
  296.     case tc_globalvar:
  297.      RETURN(VCELL(VCELL(x)));
  298.     case tc_localvar:
  299.      RETURN(STk_localvalue(x, env));
  300.     case tc_cons: {
  301.       /* Evaluate the first argument of this list (without calling eval) */
  302.      tmp = CAR(x);
  303.      switch TYPE(tmp) {
  304.            case tc_symbol:
  305.             fct=*STk_varlookup(x, env, 1);
  306.         break;
  307.        case tc_cons:
  308.         fct = EVAL(tmp); break;
  309.        case tc_globalvar:
  310.         fct = VCELL(VCELL(tmp)); break;
  311.        case tc_localvar:
  312.         fct = STk_localvalue(tmp, env); break;
  313.            default:
  314.         fct = tmp;
  315.        }
  316.  
  317.          Apply_args:
  318.      /* Find length of the parameter list */
  319.      for (len=0, tmp=CDR(x); NNULLP(tmp); len++, tmp=CDR(tmp))
  320.        if (NCONSP(tmp)) Err("eval: malformed list", x);
  321.  
  322.      /* apply parameters to fct */
  323.      tmp = CDR(x);
  324.      switch (TYPE(fct)) {
  325.        case tc_subr_0:
  326.             if (len == 0) RETURN(SUBR0(fct)());
  327.         goto Error;
  328.        case tc_subr_1:
  329.         if (len == 1) RETURN(SUBRF(fct)(EVALCAR(tmp)));
  330.         goto Error;
  331.        case tc_subr_2:
  332.         if (len == 2) RETURN(SUBRF(fct)(EVALCAR(tmp), 
  333.                         EVALCAR(CDR(tmp))));
  334.         goto Error;
  335.        case tc_subr_3:
  336.         if (len == 3) RETURN(SUBRF(fct)(EVALCAR(tmp),
  337.                         EVALCAR(CDR(tmp)),
  338.                         EVALCAR(CDR(CDR(tmp)))));
  339.         goto Error;
  340.        case tc_subr_0_or_1:
  341.         switch (len) {
  342.           case 0: RETURN(SUBRF(fct)(UNBOUND));
  343.           case 1: RETURN(SUBRF(fct)(EVALCAR(tmp)));
  344.           default: goto Error;
  345.         }
  346.        case tc_subr_1_or_2:
  347.         switch (len) {
  348.           case 1: RETURN(SUBRF(fct)(EVALCAR(tmp), UNBOUND));
  349.           case 2: RETURN(SUBRF(fct)(EVALCAR(tmp), 
  350.                         EVALCAR(CDR(tmp))));
  351.           default: goto Error;
  352.         }
  353.        case tc_subr_2_or_3:
  354.         switch (len) {
  355.           case 2: RETURN(SUBRF(fct)(EVALCAR(tmp), 
  356.                         EVALCAR(CDR(tmp)),
  357.                         UNBOUND));
  358.           case 3: RETURN(SUBRF(fct)(EVALCAR(tmp), 
  359.                         EVALCAR(CDR(tmp)),
  360.                         EVALCAR(CDR(CDR(tmp)))));
  361.           default: goto Error;
  362.         }
  363.        case tc_ssubr:
  364.         RETURN(SUBRF(fct)(tmp, env, TRUE));
  365.        case tc_fsubr:
  366.         RETURN(SUBRF(fct)(tmp, env, len));
  367.        case tc_syntax:
  368.         if (SUBRF(fct)(&x, env, len) == Truth) goto Top;
  369.         RETURN(x);
  370.        case tc_lsubr:
  371.         RETURN(SUBRF(fct)(eval_args(tmp, env), len));
  372. #ifdef USE_STKLOS
  373.        case tc_instance:
  374.             if (PUREGENERICP(fct)) {
  375.           /* Do it in C */
  376.           if (NULLP(THE_SLOT_OF(fct, S_methods)))
  377.             Apply(VCELL(Intern("no-method")), LIST2(fct, tmp));
  378.  
  379.           tmp = eval_args(tmp, env);
  380.           fct = STk_compute_applicable_methods(fct, tmp, len, FALSE);
  381.           /* fct is the list of applicable methods. Apply the
  382.            * first one with the tail of the list as first
  383.            * parameter (next-method). If fct is NIL, that's because
  384.            * the no-applicable-method triggered didn't call error.
  385.            */
  386.           if (NULLP(fct)) RETURN(UNDEFINED);
  387.           tmp = Cons(STk_make_next_method(CDR(fct), tmp), tmp);
  388.           fct = THE_SLOT_OF(CAR(fct), S_procedure);
  389.           env = STk_extend_env(CLOSURE_PARAMETERS(fct),
  390.                        tmp,
  391.                        fct->storage_as.closure.env,
  392.                        x);
  393.           tmp = CDR(fct->storage_as.closure.code);
  394.           goto Begin;
  395.         }
  396.         else
  397.           /* Do it in Scheme */
  398.           RETURN(STk_apply_user_generic(fct, tmp));
  399.  
  400.        case tc_next_method:
  401.             /* By nature, next methods cannot be recursive; so, we can 
  402.          * call the apply-next-method function */
  403.             RETURN(STk_apply_next_method(fct, eval_args(tmp, env)));
  404. #endif               
  405. #ifdef USE_TK
  406.       case tc_tkcommand:
  407.             RETURN(STk_execute_Tcl_lib_cmd(fct, tmp, env, 1));
  408. #endif
  409.        case tc_closure:
  410.         env = STk_extend_env(CLOSURE_PARAMETERS(fct),
  411.                      eval_args(tmp, env),
  412.                      fct->storage_as.closure.env,
  413.                      x);
  414.         tmp = CDR(fct->storage_as.closure.code);
  415.         /* NOBREAK */
  416. Begin:       case tc_begin:
  417.         for( ; NNULLP(CDR(tmp)); tmp=CDR(tmp))
  418.           EVALCAR(tmp);
  419.         x = CAR(tmp);
  420.             goto Top;
  421.        case tc_cont:
  422.         if (len == 1) STk_throw(fct, EVALCAR(tmp));
  423.         goto Error;
  424.        case tc_let:
  425.         env = STk_fast_extend_env(CAR(tmp), 
  426.                       eval_args(CAR(CDR(tmp)),env), 
  427.                       env);
  428.         tmp = CDR(CDR(tmp));
  429.         goto Begin;
  430.        case tc_letstar:
  431.         {
  432.           SCM l1=CAR(tmp), l2=CAR(CDR(tmp));
  433.           /* Create a rib to avoid that internal def be seen as global  */
  434.           env = STk_fast_extend_env(NIL, NIL, env); 
  435.           for ( ; NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
  436.             env = STk_fast_extend_env(Cons(CAR(l1), NIL), 
  437.                           Cons(EVALCAR(l2), NIL), env);
  438.           tmp =  CDR(CDR(tmp));
  439.           goto Begin;
  440.         }
  441.        case tc_letrec:
  442.         {
  443.           SCM bindings = NIL, l1=CAR(tmp), l2=CAR(CDR(tmp));
  444.           
  445.           /* Make a binding list an extend current with it */
  446.           for (len=STk_llength(l1); len; len--) 
  447.             bindings=Cons(UNBOUND,bindings);
  448.           env = STk_fast_extend_env(l1, bindings, env);
  449.  
  450.           /* Eval init forms in the new environment */
  451.           for (l1 = CAR(tmp); NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
  452.             *(STk_varlookup(CAR(l1), env, 0)) = EVALCAR(l2);
  453.  
  454.           /* Evaluate body */
  455.           tmp =  CDR(CDR(tmp));
  456.           goto Begin;
  457.         }
  458.            case tc_macro:
  459.             x = Apply(fct->storage_as.macro.code, x);
  460.             goto Top;
  461.        case tc_quote:
  462.         RETURN(CAR(tmp));
  463.        case tc_lambda:
  464.         NEWCELL(x, tc_closure);
  465.         x->storage_as.closure.env  = env;
  466.         x->storage_as.closure.code = tmp;
  467.         RETURN(x);
  468.        case tc_if:
  469.         x = NEQ(EVALCAR(tmp), Ntruth) ? CAR(CDR(tmp))
  470.                           : CAR(CDR(CDR(tmp)));
  471.         goto Top;
  472.        case tc_setq:
  473.         *(STk_varlookup(CAR(tmp), env, 0)) = EVALCAR(CDR(tmp));
  474.         if (TRACED_VARP(CAR(tmp))) STk_change_value(CAR(tmp), env);
  475.         RETURN(UNDEFINED);
  476.        case tc_cond:
  477.         /* Don't use tmp because 
  478.          *     1) it's in a register 
  479.          *     2) we can arrive from tc_syntax 
  480.          */
  481.         x = CDR(x); /* x is a "normal" var */
  482.         if (eval_cond(&x, env) == Truth) goto Top;
  483.         RETURN(x);
  484.        case tc_and:
  485.         if (!len) RETURN(Truth);
  486.         for (--len ; len; len--, tmp=CDR(tmp))
  487.           if (EVALCAR(tmp) == Ntruth) RETURN(Ntruth);
  488.         x=CAR(tmp);
  489.         goto Top;
  490.        case tc_or:
  491.         if (!len) RETURN(Ntruth);
  492.         for (--len; len; len--, tmp=CDR(tmp))
  493.           if ((fct=EVALCAR(tmp)) != Ntruth) RETURN(fct);
  494.         x=CAR(tmp);
  495.         goto Top;
  496.        case tc_call_cc:
  497.         if (len != 1) goto Error;
  498.         x = EVALCAR(tmp);
  499.         if (STk_do_call_cc(&x) == Truth) goto Top;
  500.         RETURN(x);
  501.        case tc_extend_env:
  502.              fct = EVALCAR(tmp);
  503.             if (NENVP(fct)) Err("extend-env: bad environment", fct);
  504.         tmp = CDR(tmp);
  505.         env = STk_append(LIST2(fct->storage_as.env.data, env), 2);
  506.         goto Begin;
  507.        case tc_apply:
  508.         tmp = eval_args(tmp, env);
  509.         fct = CAR(tmp);
  510.         tmp = STk_liststar(CDR(tmp),len-1);
  511.         if (STk_llength(tmp) == -1) Err("apply: bad parameter list", tmp);
  512.  
  513.         switch (TYPE(fct)) {
  514.           case tc_closure: env=STk_extend_env(
  515.                             CAR(fct->storage_as.closure.code),
  516.                         tmp,
  517.                         fct->storage_as.closure.env,
  518.                         x);
  519.                        tmp = CDR(fct->storage_as.closure.code);
  520.                        goto Begin;
  521.             case tc_apply: /* Here we are not tail recursive. (i.e. when
  522.                     * we have something like (apply apply f ...)
  523.                     * We cannot use a goto, since we should go again
  524.                     * in tc_apply which will re-evaluates its 
  525.                     * parameters. However, this kind of call 
  526.                     * should be rare ...
  527.                     */
  528.                    RETURN(Apply(fct, tmp));
  529.             case tc_call_cc:
  530.             case tc_dynwind: x=Cons(fct, tmp);
  531.                      goto Top;
  532. #ifdef USE_STKLOS
  533.             case tc_instance:
  534.                            RETURN(STk_apply_generic(fct, tmp));
  535.             case tc_next_method:
  536.                            RETURN(STk_apply_next_method(fct,tmp));
  537. #endif
  538.             default:          RETURN(Apply(fct, tmp));
  539.         }
  540.            default:
  541.         if (EXTENDEDP(fct)) {
  542.           if (STk_extended_eval_parameters(fct)) 
  543.             tmp = eval_args(tmp, env);
  544.           RETURN(STk_extended_apply(fct, tmp, env));
  545.         }
  546.             Err("eval: bad function in ", x);
  547.      }
  548.        }
  549.      default:
  550.        RETURN(x);
  551.      }
  552. Out:
  553.   stack = infos.previous;
  554.   return tmp;
  555.  
  556. Error:
  557.   Err("eval: Bad number of parameters", x);
  558.   return UNDEFINED; /* never reached */
  559. }
  560.  
  561.  
  562. SCM STk_apply(SCM fct, SCM param)
  563. {
  564. Top:
  565.   switch TYPE(fct) {
  566.     case tc_subr_0:
  567.          if (NULLP(param)) return SUBR0(fct)();
  568.      break;
  569.     case tc_subr_1:
  570.      if  (STk_llength(param) == 1)return SUBRF(fct)(CAR(param));
  571.      break;
  572.     case tc_subr_2:
  573.      if (STk_llength(param) == 2)
  574.        return SUBRF(fct)(CAR(param), CAR(CDR(param)));
  575.      break;
  576.     case tc_subr_3:
  577.      if (STk_llength(param) == 3)
  578.        return SUBRF(fct)(CAR(param), CAR(CDR(param)), CAR(CDR(CDR(param))));
  579.      break;
  580.     case tc_subr_0_or_1:
  581.      switch (STk_llength(param)) {
  582.        case 0: return SUBRF(fct)(UNBOUND);
  583.        case 1: return SUBRF(fct)(CAR(param));
  584.      }     
  585.     case tc_subr_1_or_2:
  586.      switch (STk_llength(param)) {
  587.        case 1: return SUBRF(fct)(CAR(param), UNBOUND);
  588.        case 2: return SUBRF(fct)(CAR(param), CAR(CDR(param)));
  589.      }
  590.  
  591.     case tc_subr_2_or_3:
  592.      switch (STk_llength(param)) {
  593.        case 2: return SUBRF(fct)(CAR(param), CAR(CDR(param)));
  594.        case 3: return SUBRF(fct)(CAR(param), CAR(CDR(param)), 
  595.                      CAR(CDR(CDR(param))));
  596.      }
  597.     case tc_ssubr:
  598.      return SUBRF(fct)(param, NIL, STk_llength(param));
  599.     case tc_lsubr:
  600.      return SUBRF(fct)(param, STk_llength(param));
  601.     case tc_cont:
  602.      if (STk_llength(param) == 1)
  603.        STk_throw(fct, CAR(param));     
  604.     case tc_closure: { 
  605.          register SCM env = STk_extend_env(CAR(fct->storage_as.closure.code),
  606.                        param,
  607.                        fct->storage_as.closure.env,
  608.                        fct);
  609.      register SCM code;
  610.      
  611.      for(code=CDR(fct->storage_as.closure.code); NNULLP(code); code=CDR(code))
  612.        param = EVALCAR(code);
  613.      return param;
  614.        }
  615. #ifdef USE_STKLOS
  616.     case tc_instance:
  617.         return STk_apply_generic(fct, param);
  618.     case tc_next_method:
  619.         return STk_apply_next_method(fct, param);
  620. #endif
  621. #ifdef USE_TK
  622.     case tc_tkcommand:
  623.           return STk_execute_Tcl_lib_cmd(fct, param, NIL, 0);
  624. #endif
  625.     case tc_apply:
  626.      fct   = CAR(param);
  627.      param = STk_liststar(CDR(param), STk_llength(CDR(param)));
  628.      goto Top;
  629.     default:
  630.      if (EXTENDEDP(fct)) 
  631.        if (STk_extended_procedurep(fct)) 
  632.          return STk_extended_apply(fct, param, UNBOUND);
  633.      Err("apply: bad procedure", fct);
  634.   }
  635.  
  636.   Err("apply: bad number of arguments to apply", Cons(fct,param));
  637.   return UNDEFINED; /* never reached */
  638. }
  639.  
  640.  
  641. PRIMITIVE STk_user_eval(SCM expr, SCM env)
  642. {
  643.   if (env == UNBOUND) env = STk_globenv;
  644.   else 
  645.     if (NENVP(env)) Err("eval: bad environment", env);
  646.  
  647.   /* If expr is a list, make a copy of it to avoid the user to see it modified
  648.    * (i.e. "recoded") when eval returns
  649.    */
  650.   if (CONSP(expr)) expr = STk_copy_tree(expr);
  651.   return STk_eval(expr, env->storage_as.env.data);
  652. }
  653.  
  654.  
  655. PRIMITIVE STk_eval_string(SCM str, SCM env)
  656. {
  657.   SCM result;
  658.  
  659.   if (env == UNBOUND) env = STk_globenv;
  660.   else 
  661.     if (NENVP(env)) Err("eval-string: bad environment", env);
  662.  
  663.   if (NSTRINGP(str)) Err("eval-string: Bad string", str);
  664.   result = STk_internal_eval_string(CHARS(str), 
  665.                     ERR_READ_FROM_STRING, 
  666.                     env->storage_as.env.data);
  667.   return result == EVAL_ERROR? UNDEFINED: result;
  668. }
  669.